home *** CD-ROM | disk | FTP | other *** search
/ Magnum One / Magnum One (Mid-American Digital) (Disc Manufacturing).iso / d18 / nrpas13.arc / CEL.PAS < prev    next >
Pascal/Delphi Source File  |  1991-05-01  |  864b  |  47 lines
  1. FUNCTION cel(qqc,pp,aa,bb: real): real;
  2. LABEL 1;
  3. CONST
  4.    ca=0.0003;
  5.    pio2=1.5707963268;
  6. VAR
  7.    a,b,e,f,g: real;
  8.    em,p,q,qc: real;
  9. BEGIN
  10.    IF (qqc = 0.0) THEN BEGIN
  11.       writeln('pause in routine CEL'); readln END;
  12.    qc := abs(qqc);
  13.    a := aa;
  14.    b := bb;
  15.    p := pp;
  16.    e := qc;
  17.    em := 1.0;
  18.    IF (p > 0.0) THEN BEGIN
  19.       p := sqrt(p);
  20.       b := b/p
  21.    END ELSE BEGIN
  22.       f := qc*qc;
  23.       q := 1.0-f;
  24.       g := 1.0-p;
  25.       f := f-p;
  26.       q := q*(b-a*p);
  27.       p := sqrt(f/g);
  28.       a := (a-b)/g;
  29.       b := -q/(g*g*p)+a*p
  30.    END;
  31. 1:   f := a;
  32.    a := a+b/p;
  33.    g := e/p;
  34.    b := b+f*g;
  35.    b := b+b;
  36.    p := g+p;
  37.    g := em;
  38.    em := qc+em;
  39.    IF (abs(g-qc) > (g*ca)) THEN BEGIN
  40.       qc := sqrt(e);
  41.       qc := qc+qc;
  42.       e := qc*em;
  43.       GOTO 1
  44.    END;
  45.    cel := pio2*(b+a*em)/(em*(em+p))
  46. END;
  47.